PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/robinson/passarry.frm

Visual Basic Form | 1994-12-05 | 5.8 KB | 206 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00808000&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Array to Excel"
   ClientHeight    =   5565
   ClientLeft      =   1110
   ClientTop       =   1485
   ClientWidth     =   5850
   ClipControls    =   0   'False
   Height          =   5970
   Icon            =   PASSARRY.FRX:0000
   Left            =   1050
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   5565
   ScaleWidth      =   5850
   Top             =   1140
   Width           =   5970
   Begin TextBox Text1
      Height          =   345
      Left            =   150
      TabIndex        =   3
      Top             =   585
      Width           =   2130
   End
   Begin CommandButton Command1
      Caption         =   "Send Data to Excel"
      Height          =   495
      Left            =   2910
      TabIndex        =   2
      Top             =   1800
      Width           =   2415
   End
   Begin OLE OLE1
      BackColor       =   &H00C0C0C0&
      Class           =   "Excel.Chart.5"
      fFFHk           =   -1  'True
      Height          =   3075
      Left            =   75
      SizeMode        =   1  'Stretch
      TabIndex        =   1
      Top             =   2445
      Width           =   5685
   End
   Begin Grid Grid1
      Cols            =   5
      Height          =   1485
      HighLight       =   0   'False
      Left            =   2415
      Rows            =   6
      TabIndex        =   0
      Top             =   105
      Width           =   2895
   End
   Begin Image Image1
      Height          =   705
      Left            =   630
      Top             =   1275
      Width           =   795
   End
   Begin Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H8000000F&
      BackStyle       =   0  'Transparent
      Caption         =   "Enter Data:"
      Height          =   195
      Left            =   150
      TabIndex        =   4
      Top             =   345
      Width           =   990
   End
Option Explicit
Dim xlSheet As Object
Dim R As Object
Dim sOldValue As String
Sub Command1_Click ()
    Dim iRow As Integer
    Dim iCol As Integer
    Dim x As Integer
    Dim y As Integer
    Dim ArrStr As String
    Const HOURGLASS = 11
    Const DEFAULT = 0
    Const OLE_CREATE_EMBED = 0
    Const OLE_ACTIVATE = 7
    Screen.MousePointer = HOURGLASS
    'create an embedded object in the OLE control
    OLE1.Action = OLE_CREATE_EMBED
    OLE1.Action = OLE_ACTIVATE
    DoEvents
    'if there are 0 worksheets, add one
    If OLE1.Object.Parent.Worksheets.count = 0 Then
      OLE1.Object.Parent.Worksheets.Add
    End If
    'use a range object the size of the grid: 5 rows x 4 cols
    Set xlSheet = OLE1.Object.Parent.Worksheets(1)
    Set R = xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(6, 5))
        x = 1
        y = 1
        ArrStr = "={"
        For x = 0 To grid1.Rows - 1
          grid1.Row = x
          For y = 0 To grid1.Cols - 1
            grid1.Col = y
            If y > 0 And x > 0 Then
              ArrStr = ArrStr + grid1.Text + ","
            Else
              ArrStr = ArrStr + """" + grid1.Text + ""","
            End If
          Next y
          Mid$(ArrStr, Len(ArrStr), 1) = ";"

        Next x

        Mid$(ArrStr, Len(ArrStr), 1) = "}"
        On Error Resume Next
        R.FormulaArray = ArrStr
        If Err Then
            ' Debug.Print Arrstr
            MsgBox "Too Long: " + CStr(Len(ArrStr))
        Else
            R.Copy
            R.PasteSpecial -4163
            xlSheet.Application.CutCopyMode = False
        End If

      OLE1.Object.Parent.Charts(1).Activate
      R.Parent.Parent.ActiveChart.ChartWizard R

      Screen.MousePointer = DEFAULT
End Sub
Sub Form_Load ()
    Dim x As Integer, y As Integer, z As Integer
    'set the icon
    Image1.Picture = Form1.Icon
    'set the column headings: Col 0
    x = 0
    y = 1
    grid1.Col = x
    grid1.Row = y
    grid1.Text = "1990"
    grid1.Row = y + 1
    grid1.Text = "1991"
    grid1.Row = y + 2
    grid1.Text = "1992"
    grid1.Row = y + 3
    grid1.Text = "1993"
    grid1.Row = y + 4
    grid1.Text = "1994"
    'set the row headings: row 0
    x = 1
    y = 0
    grid1.Col = x
    grid1.Row = y
    grid1.Text = "Q1"
    grid1.Col = x + 1
    grid1.Text = "Q2"
    grid1.Col = x + 2
    grid1.Text = "Q3"
    grid1.Col = x + 3
    grid1.Text = "Q4"
    'fill in the values of the grid
    For x = 1 To grid1.Cols - 1
      grid1.Col = x
      For y = 1 To grid1.Rows - 1
        grid1.Row = y
        z = z + 200
        grid1.Text = Trim$(Str$(z))
      Next y
    Next x
    grid1.Refresh
    Text1.Text = grid1.Text
    sOldValue = grid1.Text
End Sub
Sub Grid1_KeyPress (KeyAscii As Integer)
  If KeyAscii > 31 Then
    Text1.Text = Text1.Text + Chr(KeyAscii)
  End If
End Sub
Sub Grid1_KeyUp (KeyCode As Integer, Shift As Integer)
    Const KEY_F2 = &H71
    Const KEY_ESCAPE = &H1B
    Select Case KeyCode
      Case KEY_F2
        Text1.SelStart = 0
        If Len(Text1.Text) > 0 Then
          Text1.SelLength = Len(Text1.Text)
        End If
        Text1.SetFocus
      Case KEY_ESCAPE
        Text1.Text = sOldValue
    End Select
End Sub
Sub Grid1_RowColChange ()
  Text1.Text = grid1.Text
  sOldValue = Text1.Text
End Sub
Sub Text1_Change ()
  grid1.Text = Text1.Text
End Sub
Sub Text1_KeyPress (KeyAscii As Integer)
    Const KEY_RETURN = &HD
    If KeyAscii = KEY_RETURN Then grid1.SetFocus
End Sub